(GLOBAL 
   (FUNCTIONS IN-CONTEXT OBJECT CFRAME PUSH-CONTEXT POP-CONTEXT 
      SPLICE FETCHI FETCHM REALIZE UNREALIZE REAL UNREAL  
      ACTUALIZE UNACTUALIZE DPUTCF DGETCF DREMCF DPUT DGET DREM 
      DPUT+ DGET+ DREM+ PRESENT ABSENT DATUM MENTIONERS C-MARKER 
      /!" IF-NEEDED IF-ADDED IF-REMOVED DATA-INIT FETCH ADD REMOVE 
      INSERT KILL FLUSH NEW-CONTEXT PATH)
   (RESERVED /! /!/! /!/? /!/, /!/' *CONTEXT DATUM *CFRAME GLOBAL 
      *OBJECT *POSSIBILITIES CONTEXT *ITEM *METHOD *IGNORE))


(DECLARE   (SYMBOLS T) (GENPREFIX \D) (GENSYM 'D)
   (SPECIAL CFRAMES CNUM CONTEXT DATUM CMARKERS TYPE PATTERN 
      GLOBAL INCCON NUMACT NUMCON *CNUM
      *IF-ADDEDS *IF-NEEDEDS *IF-REMOVEDS *INDEXTHRESHOLD *ITEMS NEW)
   (*FEXPR /!" CDEFUN CERR CSETQ /: /, 
      GCCON IF-ADDED IF-NEEDED IF-REMOVED)
   (*LEXPR BIND ABSENT ADD CEVAL CFRAME CSET VLOC DGET
      DGET+ DPUT DPUT+ DREM DREM+ FETCH FETCHI
      FETCHM INSERT KILL MATCH NOTE OBJECT POP-CONTEXT PRESENT
      DATA-INIT PUSH-CONTEXT REAL REALIZE REMOVE RVALUE UNREAL
      UNREALIZE)
   (*EXPR ARGS DATUM CMARKERS PATTERN)
   (**ARRAY FRAMES RFRAMES))

(SETQ *INDEXTHRESHOLD 10.)(DEFUN OBJECT N
   (LIST '*OBJECT (COND ((= N 0) NIL)
                        ((= N 1) (ARG 1))
                        ((TMA))   ))   )

(DEFUN TMA ()
   (CERR TOO MANY ARGUMENTS)   )

(DEFUN TFA ()
   (CERR TOO FEW ARGUMENTS)   )

(DECLARE (UNSPECIAL CMARKERS TYPE))

(DEFUN MAKE-METHOD (TYPE BOD)
   (PROG (FIRST OLDM CMARKERS)
      (COND ((ATOM (SETQ FIRST (CAR BOD)))
             (SETQ CMARKERS
                   (COND ((SETQ OLDM (GET FIRST 'DATUM))
                          (CDR (CMARKERS OLDM)))   ))
             (PUTPROP FIRST 
                      (NCONC (LIST TYPE FIRST (CADR BOD) (CDDR BOD))
                             CMARKERS)
                      'DATUM)
             (RETURN FIRST))
            ((RETURN (LIST TYPE NIL FIRST (CDR BOD))))   )   ))

(DECLARE (SPECIAL CMARKERS TYPE))


(DEFUN IF-NEEDED FEXPR (A)
   (MAKE-METHOD 'IF-NEEDED A))


(DEFUN IF-ADDED FEXPR (A)
   (MAKE-METHOD 'IF-ADDED A))


(DEFUN IF-REMOVED FEXPR (A)
   (MAKE-METHOD 'IF-REMOVED A))


(DEFUN DATA-INIT K
 ((LAMBDA (N M)
   (COND ((BOUNDP 'NUMACT)
          (DO I 0 (1+ I) (= I NUMACT)
             (DO DATA (CDDR (FRAMES I)) (CDR DATA) (NULL DATA)
                ((LAMBDA (D)
                    (AND (ATOM D) (RPLACD (CMARKERS D) NIL)))
                 (CAR DATA))   ))))
   (SETQ NUMCON N INCCON M)
   (ARRAY FRAMES NIL NUMCON)
   (ARRAY RFRAMES T NUMCON)
   (STORE (FRAMES 0) (SETQ GLOBAL (LIST '*CFRAME (SETQ *CNUM 0))))
   (STORE (RFRAMES 0) (CDR GLOBAL))
   (SETQ CONTEXT (LIST '*CONTEXT GLOBAL))
   (SETQ NUMACT 1)
   (PUTPROP 'ITEM (SETQ *ITEMS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
   (PUTPROP 'IF-NEEDED (SETQ *IF-NEEDEDS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
   (PUTPROP 'IF-ADDED (SETQ *IF-ADDEDS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
   (PUTPROP 'IF-REMOVED (SETQ *IF-REMOVEDS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
   (SSTATUS INTERRUPT 20. 'GCCON))
  (COND ((> K 0)(ARG 1)) (T 100.))
  (COND ((> K 1)(ARG 2)) (T 10.)) ))
(DECLARE (UNSPECIAL PATTERN))

(DEFUN FETCH N
   (PROG (PATTERN CON)
      (SETQ PATTERN (ARG 1)
            CON (GETCONTEXT 1 N))      
      (RETURN 
          (CONS (LIST '*POSSIBILITIES PATTERN)
                (CONS '*IGNORE
                    (NCONC (FETCHI1 PATTERN CON) 
                           (FETCHM1 PATTERN *IF-NEEDEDS CON)))))   ))



(DEFUN FETCHI N
    (CONS (LIST '*POSSIBILITIES (ARG 1))
          (CONS '*IGNORE (FETCHI1 (ARG 1) (GETCONTEXT 1 N))))   )


(DEFUN FETCHM N
   (COND ((> N 3) (TMA))   )
   ((LAMBDA (CON)
      (CONS (LIST '*POSSIBILITIES (ARG 1))
            (CONS '*IGNORE
	             (FETCHM1 (ARG 1) 
	                      (COND ((< N 2) *IF-NEEDEDS)
	                            ((GET (ARG 2) '*INDEX))   )
	                      CON)))   )
    (COND ((< N 3) (/, CONTEXT))
          ((ARG 3))   ))   )


(DEFUN FETCHI1 (PATTERN CON)
   (PROG (ALISTS)
      (RETURN (MAPCAN '(LAMBDA (ITEM)
                          (COND ((SETQ ALISTS (MATCH PATTERN (CAR ITEM)))
                                 (LIST (LIST '*ITEM ITEM (CAR ALISTS)))) ))
                      (SEARCH *ITEMS PATTERN T (CDR CON))))   ))


(DEFUN FETCHM1 (PATTERN INDEX CON)
   (MAPCAN '(LAMBDA (METHOD)
              ((LAMBDA (MRESULT)
                  (COND (MRESULT
                         (LIST (CONS '*METHOD (CONS METHOD (NCONC MRESULT (LIST PATTERN))))))   ))
               (MATCH (PATTERN METHOD) PATTERN)))
           (SEARCH INDEX PATTERN NIL (CDR CON)))   )

(DECLARE (SPECIAL PATTERN))
(DEFUN REAL N (AND (REALITY (ARG 1) (GETCONTEXT 1 N)) (ARG 1))   )


(DEFUN UNREAL N (AND (NOT (REALITY (ARG 1) (GETCONTEXT 1 N))) (ARG 1))   )


(DEFUN PRESENT N
   (PROG (CON PAT CANDIDATES ALISTS)
      (SETQ PAT (ARG 1)
            CON (GETCONTEXT 1 N)
            CANDIDATES (SEARCH *ITEMS PAT T (CDR CON)))
LOOP  (COND ((NULL CANDIDATES) (RETURN NIL))
            ((SETQ ALISTS (MATCH PAT (ITEM (CAR CANDIDATES))))
             (MAPC '(LAMBDA (PAIR)
                         (CSET (CAR PAIR) (CADR PAIR)))
                   (CAR ALISTS))
             (RETURN (CAR CANDIDATES)))   )
       (SETQ CANDIDATES (CDR CANDIDATES))
       (GO LOOP)   ))


(DEFUN ABSENT N
    (UNREAL (DATUM (ARG 1)) (GETCONTEXT 1 N))   )
(DECLARE (UNSPECIAL PATTERN))

(DEFUN SEARCH (INDEX PATTERN ITEM CON)
    (MAPCAN '(LAMBDA (THING)
                (COND ((REALITY1 (CDR (CMARKERS THING)) 
                                 CON) 
                       (LIST THING))   ))
             (ISEARCH INDEX PATTERN ITEM))   )

(DECLARE (SPECIAL PATTERN))


(DEFUN REALITY (DATUM CON)
   (REALITY1 (CDR (CMARKERS DATUM)) (CDR CON)))


(DEFUN REALITY1 (CMARKERS CFRAMES)
   (PROG (CM CON)
      (SETQ CON CFRAMES)
LOOP  (COND ((SETQ CM (MFINTERSECT))
             (OR (INVISIBLE (CADR CM) CON) (RETURN CM))
             (SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
             (GO LOOP))
            ((RETURN NIL))   )   ))


(DEFUN DATUM (SKELETON)
   (PROG (CANDIDATES)
      (SETQ CANDIDATES (ISEARCH *ITEMS SKELETON T))
LOOP  (COND ((NULL CANDIDATES) (RETURN (LIST SKELETON)))
            ((EQUAL (ITEM (CAR CANDIDATES)) SKELETON)
             (RETURN (CAR CANDIDATES)))   )
      (SETQ CANDIDATES (CDR CANDIDATES))
      (GO LOOP)   ))(DEFUN ADD N (REALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N))   )


(CDEFUN ADD (THING "OPTIONAL" (CONTEXT CONTEXT))
   (REALIZE (/@ DATUMIZE (/, THING)) CONTEXT)   )


(DEFUN REMOVE N (UNREALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N))   )


(CDEFUN REMOVE (THING "OPTIONAL" (CONTEXT CONTEXT))
   (UNREALIZE (/@ DATUMIZE (/, THING)) CONTEXT)   )


(DEFUN INSERT N
   ((LAMBDA (D)
       (REVEAL D (GETCONTEXT 1 N)) D)
    (DATUMIZE (ARG 1)))   )


(DEFUN KILL N
   ((LAMBDA (D)
       (HIDE D (GETCONTEXT 1 N)) D)
    (DATUMIZE (ARG 1)))   )


(DEFUN ACTUALIZE N (REVEAL (ARG 1) (GETCONTEXT 1 N)) (ARG 1)   )


(DEFUN UNACTUALIZE N (HIDE (ARG 1) (GETCONTEXT 1 N)) (ARG 1)   )(DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))

(DEFUN REALIZE N
   (PROG (DATUM CON PAT)
      (SETQ DATUM (ARG 1)
            CON (GETCONTEXT 1 N))
      (COND ((AND (REVEAL DATUM CON) (SETQ PAT (ITEM DATUM)))
             (CEVAL '(CALLDEMONS (/@ . PAT) (/@ . *IF-ADDEDS) (/@ . CON))))   )
      (RETURN DATUM)   ))


(CDEFUN REALIZE (DATUM "OPTIONAL" (CONTEXT CONTEXT))
   "AUX" (PAT)
   (COND ((/@ AND (REVEAL (/, DATUM) (/, CONTEXT))
                  (CSETQ PAT (ITEM (/, DATUM))))
          (CALLDEMONS PAT (/@ . *IF-ADDEDS) CONTEXT))   )
   DATUM)


(DEFUN UNREALIZE N
   (PROG (DATUM CON PAT)
      (SETQ DATUM (ARG 1)
            CON (GETCONTEXT 1 N))
      (COND ((AND (HIDE DATUM CON) (SETQ PAT (ITEM DATUM)))
             (CEVAL '(CALLDEMONS (/@ . PAT) (/@ . *IF-REMOVEDS) (/@ . CON))))   )
      (RETURN DATUM)   ))


(CDEFUN UNREALIZE (DATUM "OPTIONAL" (CONTEXT CONTEXT))
   "AUX" (PAT)
   (COND ((/@ AND (HIDE (/, DATUM) (/, CONTEXT))
                  (CSETQ PAT (ITEM (/, DATUM))))
          (CALLDEMONS PAT (/@ . *IF-REMOVEDS) CONTEXT))   )
   DATUM)

(DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON))(DEFUN CALLDEMONS (PAT INDEX CONTEXT)
   (CINTERRUPT (LIST 'RUNDAEMONS
                     PAT
                     CONTEXT
                     (SEARCH INDEX PAT NIL (CDR CONTEXT)))))

(CDEFUN RUNDAEMONS ('PAT 'CONTEXT 'METS)
   (ALLOW T)
   (/: TLP)
   (COND (METS (INVOKE (NXTMET) PAT) (GO 'TLP))))

(DEFUN NXTMET FEXPR (L)
   (PROG2 (SETQ L (CDR (VLOC 'METS))) (CAAR L) (RPLACA L (CDAR L))))
(DEFUN REVEAL (DATUM CON)
   (PROG (CM STATUS CMARKERS CFRAMES PATTERN CNUM CFRAME NEW TYPE NUM)
      (SETQ CMARKERS (ANALYZE DATUM)
            CFRAMES (SETQ CON (CDR CON))
            CM (ADDCFRAME (SETQ CFRAME (CAR CON)) CMARKERS)
            CNUM (CADR CFRAME)
            STATUS (CADR CM))
      (RPLACA (CDR CM) '+)
      (COND (STATUS (RETURN NIL))
            ((AND PATTERN NEW (NULL (CDDR CMARKERS)))
             (INDEX DATUM PATTERN (GET TYPE '*INDEX)))   )
      (SETQ CMARKERS (CDDR CMARKERS) CFRAMES (CDR CFRAMES))
LOOP  (COND ((SETQ CM (MFINTERSECT))
             (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
                    (COND ((EQUAL CNUM NUM)
                           (SETQ NEW NIL)
                           (RPLACA (CDR CM) (OR (DELETE CNUM (CADR CM) 1) '+)))   ))
                   ((SETQ STATUS T))   )
             (SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
             (GO LOOP))
            (NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME))))   )
      (RETURN (NOT STATUS))   ))


(DEFUN HIDE (DATUM CON)
   (PROG (PATTERN CFRAMES CMARKERS CNUM STATUS NUM TYPE REM OLD CFRAME CM)
      (SETQ CFRAMES (SETQ CON (CDR CON))
            CMARKERS (ANALYZE DATUM)
            CNUM (CADAR CON))
      (COND ((SETQ CM (FINDCFRAME (SETQ CFRAME (CAR CFRAMES))
                                  (CDR CMARKERS)))
             (SETQ STATUS (CADR CM) OLD T)
             (COND ((CDDR CM)
                    (RPLACA (CDR CM) NIL))
                   ((SETQ REM T)
                    (DELQ CM CMARKERS 1)
                    (AND PATTERN
                         (NULL (CDR CMARKERS))
                         (UNINDEX DATUM PATTERN (GET TYPE '*INDEX) (EQ TYPE 'ITEM))))   ))   )
      (SETQ CMARKERS (CDR CMARKERS))
LOOP  (COND ((SETQ CM (MFINTERSECT))
             (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
                    (COND (REM (SETQ REM (NOT (EQUAL CNUM NUM))))
                          ((OR OLD (SETQ OLD (EQUAL CNUM NUM))))   ))
                   ((SETQ REM NIL STATUS T)
                    (CANCEL CM CNUM))   )
             (SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
             (GO LOOP))
            (REM
             (RPLACD (CDR CFRAME) (DELQ DATUM (CDDR CFRAME) 1)))
            ((AND STATUS (NOT OLD))
             (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME))))   )
      (RETURN STATUS)   ))(DEFUN ADDCFRAME (CFRAME CMARKERS)
   (PROG (N)
      (SETQ N (CADR CFRAME))
LOOP  (COND ((OR (NULL (CDR CMARKERS)) (LESSP (CAADR CMARKERS) N))
             (RPLACD CMARKERS (CONS (LIST N NIL) (CDR CMARKERS)))
             (SETQ NEW T))
            ((EQ N (CAADR CMARKERS)))
            (T (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP))   )
      (RETURN (CADR CMARKERS))   ))



(DEFUN FINDCFRAME (CFRAME CMARKERS)
   (PROG (NF NM)
      (SETQ NF (CADR CFRAME))
LOOP  (COND ((NULL CMARKERS) (RETURN NIL))
            ((> NF (SETQ NM (CAAR CMARKERS)))
             (RETURN NIL))
            ((> NM NF)
             (SETQ CMARKERS (CDR CMARKERS))
             (GO LOOP))
            ((RETURN (CAR CMARKERS)))   )   ))


(DEFUN CANCEL (CM NUM)
   (RPLACA (CDR CM) (MERGEN NUM (CADR CM)))   )


(DEFUN MERGEN (N NL)
   (COND ((ATOM NL) (LIST N))
         ((> N (CAR NL)) (CONS N NL))
         ((RPLACD NL (MERGEN N (CDR NL))))   ))(DEFUN DPUTCF (DATUM PROPERTY INDICATOR CFRAME)
   (PROG (PATTERN TYPE CM TAIL NEW)
      (SETQ TAIL (ANALYZE DATUM)
            CM (ADDCFRAME CFRAME TAIL))
      (COND (NEW
             (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))
             (AND PATTERN (NULL (CDDR TAIL)) (INDEX DATUM PATTERN (GET TYPE '*INDEX))))   )
      (RETURN (DPUT1 CM PROPERTY INDICATOR))   ))


(DEFUN DGETCF (DATUM INDICATOR CFRAME)
   (ASSQ INDICATOR (FINDCFRAME CFRAME (CDR (CMARKERS DATUM))))   )


(DEFUN DREMCF (DATUM INDICATOR CFRAME)
   (PROG (CMARKERS PATTERN TYPE CM PAIR)
      (SETQ CMARKERS (ANALYZE DATUM)
            CM (FINDCFRAME CFRAME (CDR CMARKERS)))
      (COND ((AND CM (SETQ PAIR (ASSQ INDICATOR (CDDR CM))))
             (DELQ PAIR (CDR CM) 1)
             (COND ((NOT (OR (CADR CM) (CDDR CM)))
                    (DELQ CM CMARKERS 1)
                    (DELQ DATUM CFRAME 1))   )
             (COND ((AND PATTERN
                         (NULL (CDR CMARKERS)))
                    (UNINDEX DATUM PATTERN (GET TYPE '*INDEX) (EQ TYPE 'ITEM)))   )
             (RETURN PAIR))   )   ))
(DEFUN DPUT N
   (DPUTCF (ARG 1) (ARG 2) (ARG 3) (CADR (GETCONTEXT 3 N)))   )


(DEFUN DGET N
   ((LAMBDA (CONTEXT)
       (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR CONTEXT) NIL))
    (GETCONTEXT 2 N))   )


(DEFUN DREM N
   (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) NIL)   )(DEFUN DPUT+ N
   ((LAMBDA (CM)
       (COND (CM (DPUT1 CM (ARG 2) (ARG 3)))
             ((CERR ABSENT DATUM))   ))
    (REALITY (ARG 1) (GETCONTEXT 3 N)))   )


(DEFUN DGET+ N
   (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR (GETCONTEXT 2 N)) T)   )


(DEFUN DREM+ N
   (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) T)   )




(DEFUN DPUT1 (CM PROPERTY INDICATOR)
   (PROG (PAIR)
      (COND ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
             (RPLACA (CDR PAIR) PROPERTY))
            ((RPLACD (CDR CM)
                     (CONS (SETQ PAIR (LIST INDICATOR PROPERTY))
                           (CDDR CM))))   )
      (RETURN PAIR)   ))


(DEFUN DGET1 (CMARKERS INDICATOR CFRAMES SIGN)
   (PROG (PAIR CM CON)
      (SETQ CON CFRAMES)
LOOP  (COND ((NULL (SETQ CM (MFINTERSECT)))
             (RETURN NIL))
            ((AND SIGN (INVISIBLE (CADR CM) CON)))
            ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
             (RETURN PAIR))   )
      (SETQ CMARKERS (CDR CMARKERS)
            CFRAMES (CDR CFRAMES))
      (GO LOOP))   )


(DEFUN DREM1 (DATUM INDICATOR CFRAMES SIGN)
   (PROG (PAIR CMARKERS TAIL PATTERN TYPE CM CON)
      (SETQ CON CFRAMES
            CMARKERS (CDR (SETQ TAIL (ANALYZE DATUM))))
LOOP  (COND ((NULL (SETQ CM (MFINTERSECT)))
             (RETURN NIL))
            ((AND SIGN (INVISIBLE (CADR CM) CON)))
            ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
             (DELQ PAIR (CDR CM))
             (COND ((NOT (OR (CADR CM) (CDDR CM)))
                    (DELQ CM TAIL)
                    (DELQ DATUM (CAR CFRAMES)))   )
             (COND ((AND PATTERN (NULL (CDR TAIL)))
                    (UNINDEX DATUM PATTERN (GET TYPE '*INDEX) (EQ TYPE 'ITEM)))   )
             (RETURN PAIR))   )
      (SETQ CMARKERS (CDR CMARKERS)
            CFRAMES (CDR CFRAMES))
      (GO LOOP)   ))

(DEFUN MENTIONERS N
   (PROG (CFRAMES CMARKERS MENTIONERS SIGN CM CON)
      (COND ((< N 1) (TFA))   )
      (SETQ CFRAMES (CDR (COND ((< N 3) (/, CONTEXT))
                               ((= N 3) (ARG 3))
                               ((TMA))   ))
            SIGN (COND ((> N 1) (ARG 2))   )
            CMARKERS (CDR (CMARKERS (ARG 1)))
            CON CFRAMES)
LOOP  (COND ((SETQ CM (MFINTERSECT))
             (OR (AND SIGN (INVISIBLE (CADR CM) CON))
                 (SETQ MENTIONERS (CONS (CAR CFRAMES) MENTIONERS)))
             (SETQ CFRAMES (CDR CFRAMES)
                   CMARKERS (CDR CMARKERS))
             (GO LOOP))   )
      (RETURN (REVERSE MENTIONERS))   ))


(DECLARE (UNSPECIAL DATUM))

(DEFUN C-MARKER (DATUM CFRAME)
   (FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))   )

(DECLARE (SPECIAL DATUM))(DEFUN MFINTERSECT ()
   (PROG (NM NF CM)
ADVANCE
      (COND ((AND CMARKERS CFRAMES)
             (SETQ NF (CADAR CFRAMES)
                   CM (CAR CMARKERS)
                   NM (CAR CM)))
            ((RETURN NIL))   )
TEST  (COND ((> NF NM)
             (OR (SETQ CFRAMES (CDR CFRAMES))
                 (RETURN NIL))
             (SETQ NF (CADAR CFRAMES))
             (GO TEST))
            ((> NM NF)
             (OR (SETQ CMARKERS (CDR CMARKERS))
                 (RETURN NIL))
             (SETQ CM (CAR CMARKERS)
                   NM (CAR CM))
             (GO TEST))
            ((RETURN CM))   )   ))

(DECLARE (UNSPECIAL CMARKERS))


(DEFUN INVISIBLE (CNUMS CFRAMES)
   (AND (NOT (EQ CNUMS '+))
        (OR (NULL CNUMS)
            (PROG (NC NF)
               (SETQ NC (CAR CNUMS))
         LOOP  (COND (CFRAMES
                      (SETQ NF (CADAR CFRAMES) CFRAMES (CDR CFRAMES)))
                     ((RETURN NIL))   )
         TEST  (COND ((> NF NC) (GO LOOP))
                     ((> NC NF)
                      (OR (SETQ CNUMS (CDR CNUMS)) (RETURN NIL))
                      (SETQ NC (CAR CNUMS))
                      (GO TEST))
                     ((RETURN NC))   )   )))   )

(DECLARE (UNSPECIAL CFRAMES))


(DEFUN GETCONTEXT (K N)
   (COND ((< N K) (TFA))
         ((= N K) (/, CONTEXT))
         ((= N (SETQ K (1+ K))) (ARG K))
         ((TMA))   ))(DECLARE (UNSPECIAL PATTERN))

(DEFUN ISEARCH (INDEX PATTERN ITEM)
   (APPLY 'APPEND (CDR (ISEARCH1 INDEX PATTERN ITEM)))   )


(DEFUN ISEARCH1 (INDEX PATTERN ITEM)
   (PROG (ASCAR ASCDR)
      (COND ((NULL INDEX) (RETURN (LIST 0)))
            ((EQ (CAR INDEX) '*LIST)
             (RETURN (CONS (CADDR INDEX) (LIST (CDDDR INDEX)))))
            ((EQ (CAR INDEX) '*INDEX))
            (T (BREAK BAD-STRUCTURE-INDEX--ISEARCH T))   )
      (RETURN (COND ((OR
                      (ZEROP (CAR (SETQ ASCAR 
                                        (ASEARCH (CADDR INDEX) (CAR PATTERN) ITEM))))
                      (NULL (CDR PATTERN))
                      (> (CAR (SETQ ASCDR
                                    (ASEARCH (CDDDR INDEX) (CDR PATTERN) ITEM)))
                         (CAR ASCAR)))
                     ASCAR)
                    (ASCDR)   ))   ))


(DEFUN ASEARCH (SUBINDEX ELEMENT ITEM)
   (PROG (INDICATOR ASSOCIATION CLLIST VLIST)
      (COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) '*VARIABLE)
             (RETURN (LIST 10000)))   )
      (SETQ CLLIST
            (COND ((EQ INDICATOR '*STRUCTURE)
                   (ISEARCH1 (CAR SUBINDEX) ELEMENT ITEM))
                  ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
                   (CONS (CADR ASSOCIATION) (LIST (CDDR ASSOCIATION))))
                  ((LIST 0))   ))
      (COND ((AND (NOT ITEM)
                  (SETQ ASSOCIATION (ASSQ '*VARIABLE (CDR SUBINDEX)))
                  (SETQ VLIST (CDDR ASSOCIATION)))
             (RPLACA CLLIST (+ (CAR CLLIST) (CADR ASSOCIATION)))
             (RPLACD CLLIST (CONS VLIST (CDR CLLIST))))   )
      (RETURN CLLIST)   ))


(DEFUN ASSQ1 (IND ALIST)
   (COND ((NUMBERP IND) (ASSOC IND ALIST))
         ((ASSQ IND ALIST))   ))(DECLARE (SPECIAL THING PFORM INDEX))

(DEFUN INDEX (THING PATTERN INDEX)
   (PROG (NUM THINGS PFORM)
      (COND ((NULL INDEX) (BREAK BAD-INDEX--INDEX T))
            ((EQ (CAR INDEX) '*LIST)
             (COND ((EQUAL (SETQ NUM (1+ (CADDR INDEX)))
                           *INDEXTHRESHOLD)
                    (RPLACA INDEX '*INDEX)
                    (SETQ THINGS (CDDDR INDEX) PFORM (CADR INDEX))
                    (RPLACD (CDR INDEX) (LIST (LIST NIL) NIL))
                    (MAPC
                     (/!" LAMBDA (THING)
                          (INDEX THING (/@ .  PFORM) INDEX))
                     THINGS))
                   (T (RPLACD (CDR INDEX)
                              (CONS NUM
                                    (CONS THING (CDDDR INDEX))))
                      (RETURN THING))   ))
            ((EQ (CAR INDEX) '*INDEX)
             (SETQ PFORM (CADR INDEX)))
            ((BREAK BAD-INDEX--INDEX T))   )
      (INDEX1 THING (CAR PATTERN) (CADDR INDEX) 'CAR PFORM)
      (AND (CDR PATTERN)
           (INDEX1 THING (CDR PATTERN) (CDDDR INDEX) 'CDR PFORM))
      (RETURN THING)   ))

(DECLARE (UNSPECIAL PFORM INDEX))


(DEFUN UNINDEX (THING PATTERN INDEX ITEM)
   (COND ((NULL INDEX) (BREAK BAD-INDEX--UNINDEX T))
         ((EQ (CAR INDEX) '*LIST)
          (RPLACD (CDR INDEX)
                  (CONS (1- (CADDR INDEX))
                        (DELTHING THING (CDDDR INDEX) ITEM)))
          THING)
         ((EQ (CAR INDEX) '*INDEX)
          (UNINDEX1 THING (CAR PATTERN) (CADDR INDEX) ITEM)
          (AND (CDR PATTERN)
               (UNINDEX1 THING (CDR PATTERN) (CDDDR INDEX) ITEM))
          THING)
         ((BREAK BAD-INDEX--UNINDEX T))   ))

(DECLARE (UNSPECIAL THING))


(DEFUN INDEX1 (THING ELEMENT SUBINDEX POS PFORM)
   (PROG (INDICATOR ASSOCIATION)
      (COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) '*STRUCTURE)
             (COND ((NULL (CAR SUBINDEX))
                    (RPLACA SUBINDEX (LIST '*LIST (LIST POS PFORM) 0)))   )
             (INDEX THING ELEMENT (CAR SUBINDEX)))
            ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
             (RPLACD ASSOCIATION
                     (CONS (1+ (CADR ASSOCIATION))
                           (CONS THING (CDDR ASSOCIATION)))))
            (T (RPLACD SUBINDEX
                        (CONS (LIST INDICATOR 1 THING)
                              (CDR SUBINDEX))))   )   ))


(DEFUN UNINDEX1 (THING ELEMENT SUBINDEX ITEM)
   (PROG (ASSOCIATION INDICATOR NUM)
      (SETQ INDICATOR (ATOMIZE ELEMENT))
      (COND ((EQ INDICATOR '*STRUCTURE)
             (UNINDEX THING ELEMENT (CAR SUBINDEX) ITEM))
            ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
             (COND ((ZEROP (SETQ NUM (1- (CADR ASSOCIATION))))
                    (DELQ ASSOCIATION SUBINDEX))
                   (T (RPLACD ASSOCIATION
                              (CONS NUM 
                                    (DELTHING THING (CDDR ASSOCIATION) ITEM))))   ))   )   ))(DECLARE (SPECIAL PATTERN))

(DEFUN ANALYZE (X)
   (COND ((NULL X)
          (CERR MEANINGLESS DATUM -- ANALYZE))
         ((ATOM X)
          (ANALYZE (GET X 'DATUM)))
         ((EQ (CAR X) '*CLOSURE)
          (PROG2 (ANALYZE (CADR X)) (CDDR X) (SETQ DATUM X)))
         ((EQ (CAR X) '*OBJECT)
          (SETQ PATTERN NIL TYPE 'OBJECT)
          (CDR X))
         ((ATOM (SETQ TYPE (CAR X)))
          (SETQ PATTERN (CADDR X))
          (AND (CADR X) (SETQ DATUM (CADR X)))
          (CDDDR X))
         (T (SETQ PATTERN (CAR X) TYPE 'ITEM)
            X)   ))

(DECLARE (UNSPECIAL PATTERN))

(DEFUN CMARKERS (DATUM)
   (COND ((NULL DATUM)
          (CERR MEANINGLESS DATUM -- CMARKERS))
         ((ATOM DATUM)
          (CMARKERS (GET DATUM 'DATUM)))
         ((EQ (CAR DATUM) '*CLOSURE)
          (CDDR DATUM))
         ((EQ (CAR DATUM) '*OBJECT)
          (CDR DATUM))
         ((ATOM (CAR DATUM))
          (CDDDR DATUM))
         (DATUM)   ))


(DEFUN PATTERN (DATUM)
   (COND ((NULL DATUM)
          (CERR MEANINGLESS DATUM -- PATTERN))
         ((ATOM DATUM)
          (PATTERN (GET DATUM 'DATUM)))
         ((EQ (CAR DATUM) '*CLOSURE)
          (PATTERN (CADR DATUM)))
         ((ATOM (CAR DATUM))
          (CADDR DATUM))
         ((CAR DATUM))   ))


(DEFUN NTH (EXP N)
   (COND ((= N 1) (CAR EXP))
         ((NTH (CDR EXP) (1- N)))   ))(DEFUN DELTHING (THING LIST ITEM)
   (COND (ITEM
          (DELITEM (ITEM THING) LIST))
         ((DELQ THING LIST 1))   ))


(DEFUN DELITEM (EXP LIST)
   (COND ((NULL LIST) NIL)
         ((EQUAL EXP (ITEM (CAR LIST)))
          (CDR LIST))
         (T (RPLACD LIST (DELITEM EXP (CDR LIST))))   ))


(DEFUN MEMCAR (EXP LIST)
   (COND ((NULL LIST) NIL)
         ((EQUAL EXP (ITEM (CAR LIST)))
          LIST)
         (T (MEMCAR EXP (CDR LIST)))   ))


(DEFUN ITEM (DATUM)
   (COND ((NULL DATUM) (CERR MEANINGLESS DATUM))
         ((ATOM DATUM) (ITEM (GET DATUM 'DATUM)))
         (((LAMBDA (PAT) (AND (NOT (ATOM PAT)) PAT)) (CAR DATUM)))   ))

(DEFUN DATUMIZE (THING) (COND ((ATOM THING) THING) ((DATUM THING))   ))

(DEFUN ATOMIZE (ELEMENT)
   (COND ((ATOM ELEMENT) ELEMENT)
         ((ACTOR (CAR ELEMENT)) '*VARIABLE)
         (T '*STRUCTURE)   ))
(DEFUN PUSH-CONTEXT N
    (CONS '*CONTEXT (CONS (CFRAME) (CDR (GETCONTEXT 0 N)))))


(DEFUN POP-CONTEXT N
    (CONS '*CONTEXT (CDDR (GETCONTEXT 0 N))))


(DECLARE (UNSPECIAL CFRAMES))

(DEFUN NEW-CONTEXT (CFRAMES)
   (COND ((ORDERED CFRAMES)
          (CONS '*CONTEXT CFRAMES))
         ((CERR UNORDERED CONTEXT))   ))

(DECLARE (SPECIAL CFRAMES))


(DEFUN SPLICE (CONTEXT)
   (RPLACD (CDR CONTEXT)
           (CONS (CFRAME (NEWCNUM (CADR (CADDR CONTEXT))
                                  (CADADR CONTEXT)))
                 (CDDR CONTEXT)))
   CONTEXT)


(DECLARE (SPECIAL EXPR))

(DEFUN IN-CONTEXT (CONTEXT EXPR)
   (CEVAL '((CLAMBDA (CONTEXT) (CEVAL (/@ . EXPR))) (/@ .CONTEXT)))   )
(DECLARE (UNSPECIAL EXPR))


(CDEFUN IN-CONTEXT (CONTEXT EXPR)
   (CEVAL EXPR)   )


(DEFUN PATH (C) (CONS '*CONTEXT (MAPCAR 'CADR (CDR C)))   ) (DEFUN CFRAME K
   ((LAMBDA (NFRAME)
       (COND ((AND (= NUMACT NUMCON)(= (GCCON) NUMCON))
              (CERR TOO MANY CONTEXT-FRAMES))   )
       (STORE (FRAMES NUMACT) NFRAME)
       (STORE (RFRAMES NUMACT) (CDR NFRAME))
       (SETQ NUMACT (1+ NUMACT))
       NFRAME)
    (LIST '*CFRAME (COND ((ZEROP K) (SETQ *CNUM (+ INCCON *CNUM)))
                         (T (ARG 1))   )))   )


(DEFUN ORDERED (CLIST)
   (OR (NULL CLIST)
       (PROG NIL
    LOOP  (COND ((CDR CLIST)
                 (OR (< (CADADR CLIST) (CADAR CLIST))
                     (RETURN NIL))
                 (SETQ CLIST (CDR CLIST))
                 (GO LOOP))   )
          (RETURN T)))   )


(DEFUN NEWCNUM (LOW HIGH)
   (PROG (N INC INUSE)
      (SETQ N (// (+ LOW HIGH) 2)
            INUSE (CNUMSINUSE LOW HIGH)
            INC 1)
LOOP  (COND ((GREATERP HIGH N LOW)
             (COND ((MEMBER N INUSE)
                    (SETQ N (+ N INC)
                          INC (- 0 (1+ INC)))
                    (GO LOOP))
                   ((RETURN N))   ))
            ((CERR NO NEW CNUM BETWEEN (* LOW) AND (* HIGH)))   )   ))


(DEFUN CNUMSINUSE (LOW HIGH)
  (PROG (I NUMS J N)
      (SETQ I 0 J (1- NUMACT))
LOOP  (COND ((> I J) (RETURN NUMS))
            ((OR (> LOW (SETQ N (CAR (RFRAMES I))))
                 (> N HIGH)))
            ((SETQ NUMS (CONS N NUMS)))   )
      (SETQ I (1+ I))
      (GO LOOP)   ))(DEFUN *GCCON () (PROG (M N)
   (SETQ N 0   M NUMACT)
 
NGCLP
   (COND ((= M N) (RETURN N))
         ((EQ (CDR (FRAMES N)) (RFRAMES N))
          (SETQ N (1+ N)) (GO NGCLP)))

   (FLUSH (RFRAMES N))
   (STORE (RFRAMES N) 0)

 MGCLP
   (SETQ M (1- M))
   (COND ((= M N) (RETURN N))
         ((EQ (CDR (FRAMES M)) (RFRAMES M)) (GO EXCH)))
   (FLUSH (RFRAMES M))
   (STORE (RFRAMES M) 0)
   (GO MGCLP)

 EXCH
   (STORE (FRAMES N) (FRAMES M))
   (STORE (RFRAMES N) (RFRAMES M))
   (STORE (RFRAMES M) 0)
   (GO NGCLP)))


(DEFUN GCCON FEXPR (L) (SETQ NUMACT (*GCCON)))

(DECLARE (SPECIAL PATTERN))

(DEFUN FLUSH (CFRAME)
   (PROG (THING THINGS N PATTERN TYPE CMARKERS)
      (SETQ THINGS (CDR CFRAME) N (CAR CFRAME))
LOOP  (COND ((NULL THINGS)
             (RETURN NIL))   )
      (COND ((AND (REMCFRAME N
                             (SETQ CMARKERS (ANALYZE (SETQ THING (CAR THINGS)))))
                  PATTERN
                  (NULL (CDR CMARKERS)))
             (UNINDEX THING
                      PATTERN
                      (GET TYPE '*INDEX)
                      (EQ TYPE 'ITEM)))   )
      (SETQ THINGS (CDR THINGS))
      (GO LOOP)   ))

(DECLARE (UNSPECIAL PATTERN))
(DEFUN REMCFRAME (N CMARKERS)
   (PROG (M CM)
LOOP1 (COND ((NULL (CDR CMARKERS))
             (RETURN NIL))
            ((= N (SETQ M (CAADR CMARKERS)))
             (RPLACD CMARKERS (CDDR CMARKERS))
             (RETURN T))
            ((> N M)
             (SETQ CMARKERS (CDR CMARKERS))
             (GO LOOP1))   )
LOOP2 (SETQ CMARKERS (CDR CMARKERS))
      (COND ((NULL CMARKERS) (RETURN NIL))
            ((ATOM (CADR (SETQ CM (CAR CMARKERS))))
             (AND (MEMBER N (CADR CM))
                  (RPLACA (CDR CM)
                          (OR (DELETE N (CADR CM) 1) '+))))   )